Shareware Super Platinum 8/Shareware Super Platinum 8.iso/mac/PROGTOOL/DDPLUS63.ZIP;1/DDPLUS.PAS

Pascal/Delphi Source File | 1994-07-09 | 29.6 KB | 1,149 lines

unit DDPlus;
{$V-,F+}

interface
uses dos, crt, comio, ddscott, ddansi2, ddovr, ddovr2;
type
 CharOriginType=(localchar,remotechar);
 strptr=^string;
const
 version= 'Version 6.3; 07-09-94';

{ Changes: blame on Steve Lorenz                                             }
{ This program is a 'stripped' down version doordiver.  Most sysop things    }
{ and Term program flags have been eliminated. What has been enhanced are    }
{ the communication routines.                                                }
{ Documentation  What Documentation?  See Doordrivers docs or read the code. }
{ Here is a list of most of the additions:                                   }
{ Ansi color efficiency checking                                             }
{ IRQs 0-15 support                                                          }
{ Selectable Port Addresses                                                  }
{ DESQview support                                                           }
{ PCBoard 15 support                                                         }
{ Rip Detect or found on WC3.9+ or PCB15 dropfiles                           }
{ TriBBS dropfile support  (untested)                                        }
{ RBBS vs Super BBS Dorinfo types supported                                  }
{ CTS/RTS flow checking    (Not well documented but it works)                }
{ carrier detect on output                                                   }
{ lock baud and comm baud rates to 115,200                                   }
{ Windows,WindowsNT,OS/2,DOS 5.0+ time slice releasing.                      }
{ A Dos,Win, DV pause is taken after so many read cycles in read loop        }
{ fossil support to 38,400 using normal fossil calls.                        }
{ fossil support to 115,200 using X00 extended fossil calls.                 }
{ 6.1                                                                        }
{ Added mixture of tasker pause and loop cycles in Ripdetect and read char   }
{ to give a smoother response.                                               }
{ 6.2                                                                        }
{ Missed Done Routine in 6.1  - now doesn't close if local or X00extOK       }
{ but buffered flag is set to true.                                          }
{ There was a file being written to when door timed out.  Some OS2 systems   }
{ complained of endless pages being written to their disk.  I'm taking this  }
{ out this version.  So if you have a use for it save it and put it back in. }
{6.3                                                                         }
{ Wrong-O I guess a lot of you are using this file so I'm putting it back in.}
{ I guess only my versions will leave it out.                                }
{ Added /C to specify comport on command line.  Dropfile comport number will }
{ override this option.                                                      }

 progname: string[60] = 'Systems Door Game';
 graphics_codes: array[1..4] of string[4] = ('','.ASC','.ANS','.MUS');
 ack=#6;
 nak=#21;
 sot=#1;
var
 mintime: byte;                     {Minimum time left before user kicked off}
 notime: string;                    {Out of time filename                    }
 macro,macro_str: string;           {Used in the macro routines              }
 node_num: byte;                    {Node number                             }
 time_credit: integer;              {Time credit +/- (arrow keys)            }
 CharOrigin: CharOrigInType;        {Where character came from               }
 fouled_up: char;                   {Internal use                            }
 localcol: boolean;                 {From .CTL file: Local color enabled     }
 ansion: boolean;                   {Process ANSI locally                    }
 time_check: boolean;               {Check time left - halt if < mintime     }
 curlinenum: integer;               {current line num - used by <more>       }
 stacked: string;                   {used internally - stacked commands      }
 current_foreground: byte;          {current foreground color                }
 current_background: byte;          {current background color                }
 color_chg: boolean;                {send ANSI color change sequences?       }
 default_fore: byte;                {default foreground color                }
 default_back: byte;                {default background color                }
 cdropped: boolean;                 {carrier dropped?                        }
 bbs_time_left: integer;            {from DROP FILE: time left               }
 com_port: byte;                    {from DROP FILE: com port                }
 bbs_software: byte;                {from .CTL file: bbs type                }
 baud_rate: longint;                {from DROP FILE: baud rate               }
 statfore,statback: byte;           {status line foreground                  }
 statline: boolean;                 {status line background                  }
 graphics: byte;                    {from DROP FILE: graphics code           }
 local: boolean;                    {from DROP FILE: local mode              }
 user_number: word;           {from DROP FILE: user's access level     }
 user_first_name: string[30];       {from DROP FILE: user's first name       }
 user_last_name: string[30];        {from DROP FILE: user's last name        }
 sysop_first_name: string[30];      {from .CTL file: sysop's first name      }
 sysop_last_name: string[30];       {from .CTL file: sysop's last name       }
 board_name: string[70];            {from .CTL file: board name              }
 Pause_Code : string;
 st_hr, st_mn, st_sc: word;         {used by timer calculations              }
 color1: boolean;                   {from .CTL file: color1 mode             }
 ESMOK : boolean;                   {/ESM use esm memory                     }
 stackon: boolean;                  {process stacked commands?               }
 badchar: string;                   {internal use                            }
 fossilIO: boolean;                 {from .CTL file: fossil I/O used         }
 maxtime: word;                     {from .CTL file: maximum time in door    }
 user_access_level: word;
 numlines: byte;                    {from .CTL file: number of lines/screen  }
 oldtextmode: word;                 {original text mode                      }
 GoRip      : byte;                 { enables force RIP }
 lastsetfore: byte;                 {last set_foreground color               }
 setforecheck: boolean;             {check repetetive set_foreground calls?  }
 dropfilepath: string;              {from parm list                          }

 soutput: text;                     {Simultanious output file                }

 proc_call_ptr: pointer;            {used internally                         }
 nodirect: boolean;
 lockbaud: longint;                 {lock baud rate                          }
 com1,com2,com3,com4 : byte;        { temporary non-std comports             }
 port1,port2,port3,port4:word;
 irq1,irq2,irq3,irq4 : byte;

Procedure DV_Aware_On;
Procedure DV_Pause;
Procedure Win_Pause;
procedure close_async_port;
procedure open_async_port;
function  skeypressed: boolean;
procedure sendtext(s: string);
procedure sgoto_xy(x,y: integer);
procedure sclrscr;
procedure sclreol;
procedure swrite(s: string);
procedure swritec(ch: char);
procedure swriteln(s: string);
procedure sread_char(var ch: char);
procedure sread(var s: string);
procedure sread_num(var n: integer);
procedure sread_num_byte(var b: byte);
procedure sread_num_longint(var n: longint);
{Procedure speedread(var ch : char); }
function time_left: integer;
procedure set_foreground(f: byte);
procedure set_background(b: byte);
procedure set_color(f,b: byte);
procedure prompt(var s: string; le: integer; pc: boolean);
Procedure elapsed(time1_hour, time1_min, time1_sec, time2_hour, time2_min,
                  time2_sec: longint; var elap_hour, elap_min, elap_sec: word);
procedure get_stacked(var s: string);
procedure sread_char_filtered(var ch: char);
procedure display_status;
procedure DDAssignSoutput(var f: text);
procedure InitDoorDriver(ConfigFileName: string);
function Time_used: integer;

Implementation
{$L DVAWARE.OBJ}

Procedure DV_Aware_On;       External;
Procedure DV_Pause;          External;

var
 buffered: boolean;
 exitsave: pointer;
 tcolor,bcolor: integer;
 firsttime: boolean;

{ This releases the virtual machine time slice for MSwindows, Dos 5.0, OS/2 }
procedure Win_Pause;
const
  Win_Irpt = $2F;
var
 Regs : Registers;
begin
 with Regs do
 begin
   Ax := $1680;
   Intr(Win_Irpt,Regs);
 end;
end;

procedure textcolor(i: byte);
begin;
 if localcol then crt.textcolor(i);
 tcolor:=i;
end;

procedure textbackground(i: byte);
begin;
 if localcol then crt.textbackground(i);
 bcolor:=i;
end;

procedure elapsed(time1_hour, time1_min, time1_sec, time2_hour, time2_min,
                  time2_sec: longint; var elap_hour, elap_min, elap_sec: word);
var
 a,b,c: longint;
begin;
 if time1_hour<time2_hour then time1_hour:=time1_hour+24;
 a:=(time1_hour*3600)+(time1_min*60)+time1_sec;
 b:=(time2_hour*3600)+(time2_min*60)+time2_sec;
 c:=a-b;
 if c>=3600 then elap_hour:=c div 3600 else elap_hour:=0;
 c:=c-((c div 3600)*3600);
 if c>=60 then elap_min:=c div 60 else elap_min:=0;
 c:=c-((c div 60)*60);
 elap_sec:=c;
end;

function time_left: integer;
var
 hour, minute, second, sec100: word;
 el_hr, el_mn, el_sc: word;
begin;
 gettime(hour, minute, second, sec100);
 elapsed(hour, minute, second, st_hr, st_mn, st_sc, el_hr, el_mn, el_sc);
 time_left:=time_credit+(bbs_time_left-((el_hr*60)+el_mn));
end;

function time_used: integer;
var
 hour, minute, second, sec100: word;
 el_hr, el_mn, el_sc: word;
begin;
 gettime(hour, minute, second, sec100);
 elapsed(hour, minute, second, st_hr, st_mn, st_sc, el_hr, el_mn, el_sc);
 time_used:=(el_hr*60)+el_mn;
end;

procedure display_status;
var
 a,b: integer;
 c,d: word;
 x,y: integer;
 hour, minute, second, sec100, el_mn, el_hr, el_sc: word;
begin;
 x:=wherex;
 y:=wherey;
 cursoroff;
 window(1,1,80,numlines);
 a:=tcolor;
 b:=bcolor;
 textcolor(statfore);
 textbackground(statback);
 if firsttime then begin;
  gotoxy(1,numlines);
  clreol;
  write(user_first_name+' '+user_last_name);
  gotoxy(40-(length(progname+' - Node '+va(node_num)) div 2),numlines);
  write(progname+' - Node '+va(node_num));
  firsttime:=false;
 end;
 gettime(hour,minute,second,sec100);
 elapsed(hour,minute,second,st_hr,st_mn,st_sc,el_hr,el_mn,el_sc);
 c:=(bbs_time_left-1)+time_credit;
 c:=c-((el_hr*60)+el_mn);
 d:=60-el_sc;
 gotoxy(70,numlines);
 write(c,':',d,'   ');
 if (time_left<mintime) and (time_check) then begin;
  cursoron;
  if notime<>'' then swriteln('(*** Time limit exceeded ***)');
  swriteln('');
  halt;
 end;
 textcolor(a);
 textbackground(b);
 window(1,1,80,numlines-1);
 gotoxy(x,y);
 cursoron;
end;

procedure SendText(s: string);
var
 a: integer;
begin;
 for a:=1 to length(s) do AsyncSendChar(s[a]);
end;

procedure CharOut(ch: char);
begin;
 AsyncSendChar(ch);
end;

function charin(var ch: char): boolean;
begin;
 if badchar<>'' then
   begin;
     ch:=badchar[1];
     delete(badchar,1,1);
     charin:=true;
   end
 else
  if AsyncCharPresent then
     begin;
       AsyncReceiveChar(ch);
       charin:=true;
     end
 else charin:=false;
end;

procedure Done;
begin;
  if buffered then
     AsyncFlushOutput;
  If Not X00ExtOK then
     AsyncCloseCom(com_port);
  buffered := false;
end;

procedure sclrscr;
begin;
{ if not local then CharOut(#12); }
 if not local then sendtext(#27'[2J');
 clrscr;
 curlinenum:=1;
 lastsetfore:=99;
end;

procedure sclreol;
begin;
 if not local then sendtext(#27'[K');
 clreol;
end;

procedure swritec(ch: char);
begin;
 if not local then
   AsyncSendChar(ch);
 if ansion then
    begin
      ansi_write(ch);
    end
 else
    write(ch);
end;

procedure swrite(s: string);
var
 a: integer;
 s2: string;
begin;
 if hexon then hexfilt(s);
 if not local then sendtext(s);
 if ansion then begin;
  ansi_write_str(s);
 end else write(s);
end;

procedure swriteln(s: string);
var
 a: integer;
 s2: string;
begin;
 if hexon then hexfilt(s);
 if not local then sendtext(s+#13+#10);
 if ansion then begin;
  s:=s+#13+#10;
  ansi_write_str(s);
 end else writeln(s);

end;

procedure myexit;
begin;
 If not local then done;
 if lastmode<>oldtextmode then textmode(oldtextmode);
 cursoron;
 { This should fix the problem OS/2 serial IO drivers are having exiting. }
 exitproc:=exitsave;
end;

Procedure CallProc;
inline($FF/$1E/Proc_Call_Ptr);

procedure sread_ch(var c: char);
var
 a: char;
 i,cc: integer;
begin;
 cc:=0;
 a:=chr(0);
 charorigin:=localchar;
 repeat;
  if not local then if not AsyncCarrierPresent then begin;
   writeln;
   writeln('Carrier Dropped, returning to BBS.');
   cdropped:=true;
   halt;
  end;
  if not local then if charin(a) then charorigin:=remotechar;
  if keypressed then
    begin;
       a:=readkey;
       if (a=#0) and (keypressed) then
        begin;
          a:=readkey;
        end;
     end;

  If a = chr(0) then
    If cc mod 100 = 99 then
      begin
        If DVOK then
          DV_Pause
        else
        If Os2OK or WinOK then
          Win_Pause;
      end;

  if statline then
    begin;
      inc(cc);
      if cc=1 then display_status;
      if cc=1000 then cc:=0;
    end;
 until a<>chr(0);
 c:=a;
end;

procedure sread_char(var ch: char);
var
 ch1,ch2: char;
begin;
 curlinenum:=1;
 repeat;
  if macro<>'' then
    begin;
      ch:=macro[1];
      delete(macro,1,1);
    end
  else
    repeat;
    ch:=#0;
    if fouled_up<>#0 then
      begin;
        ch:=fouled_up;
        fouled_up:=#0;
      end
    else
      begin;
        sread_ch(ch1);
        if ch1=^N then
          begin;
            ch1:=#1;
            macro:=macro_str;
          end;
        delay(20);
        if (ch1=#27) and skeypressed then
          begin;
            sread_ch(ch2);
            if ch2='[' then
              begin;
                sread_ch(ch2);
                if (ch2 in ['1'..'9']) and (skeypressed) then
                  sread_ch(ch2);
                case ch2 of
                   'A' : ch:=^E;
                   'B' : ch:=^X;
                   'C' : ch:=^D;
                   'D' : ch:=^S;
                end;
              end
            else
              begin;
                ch:=ch1;
                fouled_up:=ch2;
              end;
           end
         else
           ch:=ch1;
        end;
  until ch<>#0;
 until ch<>#1;
end;

procedure sread_char_filtered(var ch: char);
begin;
 sread_char(ch);
 if ch in [#1..#7,#10..#12,#14..#31,#127..#255] then ch:='.';
end;

procedure get_stacked(var s: string);
var
 s2: string;
 a: integer;
 b: boolean;
begin;
 s:='';
 s2:='';
 b:=false;
 if length(stacked)=0 then begin;
  s:='';
  exit;
 end;
 for a:=1 to length(stacked) do begin;
  if stacked[a]=';' then b:=true else if not b then s:=s+stacked[a];
  if b then s2:=s2+stacked[a];
 end;
 if length(s2)>=1 then delete(s2,1,1);
 stacked:=s2;
end;

procedure sread(var s: string);
var
 ch: char;
 hexsave: boolean;
begin;
 hexsave:=hexon;
 hexon:=false;
 curlinenum:=1;
 s:='';
 get_stacked(s);
 if s<>'' then swrite(s) else begin;
  repeat;
   sread_char_filtered(ch);
   if (ch<>#8) and (ch<>^M) then begin;
    s:=s+ch;
    swrite(ch);
   end;
   if (ch=chr(8)) and (length(s)>0) then begin;
    delete(s,length(s),1);
    swrite(chr(8)+' '+chr(8));
   end;
  until (ch=^M);
  if (pos(';',s)<>0) and (stackon) then begin;
   stacked:=s;
   get_stacked(s);
  end;
 end;
 swriteln('');
 hexon:=hexsave;
 if hexon then hextodec(s);
end;

procedure sread_num(var n: integer);
var
 x,y,code: integer;
 s: string;
 ch: char;
begin;
 sread(s);
 val(s,n,x);
end;

procedure sread_num_byte(var b: byte);
var
 x,y,code: integer;
 s: string;
 ch: char;
begin;
 sread(s);
 val(s,b,x);
end;

procedure sread_num_longint(var n: longint);
var
 x,y,code: integer;
 s: string;
 ch: char;
begin;
 sread(s);
 val(s,n,x);
end;
{
Procedure SpeedRead(var ch : char);
var
  a : char;
begin

  ch := chr(0);
  a := chr(0);
  If local then
    begin
      If KeyPressed then
         a :=readkey;
      If a <> chr(0) then
         ch := a
      else
      If DVOK then
         DV_Pause
      else
      If Os2OK or WinOK then
         Win_Pause;
      exit;
    end;

  charorigin:=localchar;
  If (Not AsyncCarrierPresent) then begin
      writeln;
      writeln('Carrier Dropped, returning to BBS.');
      cdropped:=true;
      halt;
    end;

  if charin(a) then
    charorigin:=remotechar;

  if (a<>chr(0)) then
    ch := a
  else
  If DVOK then
    DV_Pause
  else
  If Os2OK or WinOK then
    Win_Pause;
end;
}

function va(i: integer): string;
var
 s: string;
begin;
 str(i,s);
 va:=s;
end;

procedure set_foreground;  { f : byte }
const
  colorf: array[0..7] of integer = (30,34,32,36,31,35,33,37);
  colorb: array[0..7] of integer = (40,44,42,46,41,45,43,47);
var
 s,sb : string;
begin;
 if f > 31 then exit;
 if (f = current_foreground) then exit;
 textcolor(f);
 if not local then
   begin
   if (f=7) and (current_background=0) then
       sendtext(#27+'[0m')
   else
   begin
   If current_background = 0 then
     sb := ''
   else
     sb := ';'+va(colorb[current_background]);
   case f of
     0..7  :  begin
                s := va(colorf[f]);
                case current_foreground of
                { 0..7  : s := s;  }
                  8..31 : s := '0;'+s+sb;
               end;
            end;
     8..15 : begin
               s := va(colorf[f-8]);
               case current_foreground of
                  0..7  : s := '1;'+s;
              {   8..15 : s := s; }
                 16..31 : s := '0;1;'+s+sb;
               end;
             end;
    16..23 : begin
               s := va(colorf[f-16]);
               case current_foreground of
                  0..7  : s := '5;'+s;
                  8..15,
               { 16..23 : s := s; }
                 24..31 : s := '0;5;'+s+sb;
               end;
            end;
    24..31 : begin
               s := va(colorf[f-24]);
                case current_foreground of
                  0..7  : s := '1;5;'+s;
                  8..15 : s := '5;'+s;
                 16..23 : s := '1;'+s;
              {  24..31 : s := s; }
                end;
            end;
     end;
       sendtext(#27+'['+s+'m');
    end;
  end;
  current_foreground:=f;
end;

procedure set_background;  { b : byte }
const
 colorb: array[0..7] of integer = (40,44,42,46,41,45,43,47);
begin;
 if b > 7 then exit;
 if (b = current_background) then exit;
 textbackground(b);
 current_background:=b;
 if not local then
    if (current_foreground=7) and (b=0) then
       sendtext(#27+'[0m')
    else
       sendtext(#27+'['+va(colorb[b])+'m');
end;

Procedure Set_Color;     { f,b : byte }
const
  colorf: array[0..7] of integer = (30,34,32,36,31,35,33,37);
  colorb: array[0..7] of integer = (40,44,42,46,41,45,43,47);
var
 f1:byte;
 s:string;
 NoBackG_Ok : boolean;
begin
 if (f>31) or (b>7) then exit;
 if (f=current_foreground) and (b=current_background) then exit;
 if (f<>current_foreground) and (b<>current_background) then
    begin
      textcolor(f);
      textbackground(b);
      If not local then
         If (f=7) and (b=0) then
            sendtext(#27+'[0m')
         else
         begin
          s := '[';
          NoBackG_OK := false;
          case f of
            0..7  : begin
                      f1:=f;
                      case current_foreground of
                      { 0..7  : s := s;  }
                        8..31 : begin
                                  s := s+'0;';
                                  NoBackG_OK := true;
                                end;
                      end;
                    end;
            8..15 : begin
                      f1:=f-8;
                      case current_foreground of
                        0..7  : s := s+'1;';
                    {   8..15 : s := s; }
                       16..31 : begin
                                  s := s+'0;1;';
                                  NoBackG_OK := true;
                                end;
                      end;
                    end;
           16..23 : begin
                      f1:=f-16;
                      case current_foreground of
                        0..7  : s := s+'5;';
                        8..15,
                     { 16..23 : s := s; }
                       24..31 : begin
                                  s := s+'0;5;';
                                  NoBackG_OK := true;
                                end;
                     end;
                   end;
          24..31 : begin
                     f1:=f-24;
                     case current_foreground of
                        0..7  : s := s+'1;5;';
                        8..15 : s := s+'5;';
                       16..23 : s := s+'1;';
                    {  24..31 : s := s; }
                     end;
                   end;
         end;
         If NoBackG_OK and (b=0) then
           sendtext(#27+s+va(colorf[f1])+'m')
         else
           sendtext(#27+s+va(colorf[f1])+';'+va(colorb[b])+'m');
      end;
      current_foreground:=f;
      current_background:=b;
    end
     else
     if (f<>current_foreground) then
        set_foreground(f)
     else
       set_background(b);
end;

procedure prompt;
const
 promptcol1=7;
 promptcol2=1;
 promptcol3=15;
var
 fg,bg: integer;
 x,y,code: integer;
 ch: char;
 a: integer;
 hexsave: boolean;
begin;
 hexsave:=hexon;
 hexon:=false;
 fg:=current_foreground;
 bg:=current_background;
 get_stacked(s);
 if s<>'' then begin;
  set_foreground(promptcol3);
  while length(s)>le do delete(s,length(s),1);
  swrite(s);
  set_foreground(fg);
 end else begin;
  if not color_chg then pc:=false;
  if pc then begin;
   set_foreground(promptcol1);
   set_background(promptcol2);
   for a:=1 to le do swrite(' ');
   for a:=1 to le do swrite(#8);
   x:=wherex;
   y:=wherey;
  end;
  s:='';
  repeat;
   sread_char_filtered(ch);                                 { read(kbd,ch);}
   if (ch<>#8) and (ch<>^M) and (length(s)<le) then begin;
    s:=s+ch;
    swrite(ch);                                    { write(ch);}
   end;
   if length(s)>200 then delete(s,1,1);
   if (ch=chr(8)) and (length(s)>0) then begin;
    delete(s,length(s),1);
    swrite(chr(8));                                { write(#8,' ',#8);}
    swrite(' ');
    swrite(#8);
   end;
  until (ch=^M) or (length(s)=999);
  if pc then begin;
   set_foreground(promptcol3);
   set_background(bg);
   while wherex>x do swrite(#8);
   swrite(s);                                      { write(s);}
   while wherex<x+le do swrite(' ');               { write(' ');}
   set_foreground(fg);
  end;
  swriteln('');                                    { writeln('');}
  if pos(';',s)<>0 then begin;
   stacked:=s;
   get_stacked(s);
   while length(s)>le do delete(s,length(s),1);
  end;
 end;
 hexon:=hexsave;
end;

procedure sgoto_xy;
var
 s,s2: string;
begin;
 gotoxy(x,y);
 curlinenum := y;
 s:=#27+'[';
 str(y,s2);
 s:=s+s2;
 str(x,s2);
 s:=s+';'+s2+'f';
 if not local then sendtext(s);
end;

function skeypressed: boolean;
var
 b: boolean;
begin;
 b:=false;
 if not local then b:=AsyncCharPresent;
 if not b then b:=keypressed;
 if macro<>'' then b:=true;
 skeypressed:=b;
end;

procedure close_async_port;
begin;
 if buffered then begin;
   buffered:=false;
   AsyncFlushOutput;
   AsyncCloseUp;
 end;
end;

procedure open_async_port;
begin;
 AsyncSelectPort(com_port);
 if lockbaud=0 then
  AsyncSetBaud(baud_rate)
 else
  AsyncSetBaud(lockbaud);
 buffered := true;   { Not set in original DD - this may not be the best }
                     { place for this but it does work in my tests       }
end;
{
  }
var
 nclastchar: char;

function NewCrtOutPut(var f: textrec): integer;
var
 p: integer;
begin;
 for p:=0 to f.bufpos-1 do swrite(f.bufptr^[p]);
 f.bufpos:=0;
 NewCrtOutPut:=0;
end;

function NewCrtInPut(var f: textrec): integer;
var
 p: integer;
 ch: char;
begin;
 with f do begin;
  p:=0;
  if nclastchar=#13 then begin; nclastchar:=' '; end else repeat;
   ch:=readkey;
   nclastchar:=ch;
   write(ch);
   bufptr^[p]:=ch;
   inc(p);
   if ch=#13 then write(#10);
   if ch=#8 then begin;
    write(' '#8);
    if p>0 then dec(p);
    if p>0 then dec(p);
   end;
  until (p=bufsize-1) or (ch=#13);
  bufpos:=0;
  bufend:=p;
 end;
 NewCrtInput:=0;
end;

function NewCrtIgnore(var f: textrec): integer;
begin;
 newcrtignore:=0;
end;

function NewCRTOpen(var f: textrec): integer;
begin;
 if f.mode=fmInput then begin;
  f.inoutfunc:=@NewCrtInput;
  f.flushfunc:=@NewCrtIgnore;
 end else begin;
  f.mode:=fmOutput;
  f.inoutfunc:=@NewCrtOutPut;
  f.flushfunc:=@NewCrtOutPut;
 end;
 NewCrtOpen:=0;
end;

Function RipDetect: boolean;
var
  i,j,k : integer;
  a : char;
  s : string;
  RipYes : boolean;
begin
 RipYes := false;
 If local then
   begin
     RipDetect := RipYes;
     exit;
   end;

 sendtext(#27+'[0;30m'+#13+#10);
 writeln;
 writeln('Checking for RIP');
 sendtext(#27'[!');
 delay(222);
 s := '';
 i := 0;
 j := 0;
 charorigin:=localchar;
 repeat;

   a:=chr(0);
   inc(i);

   If Not AsyncCarrierPresent then
     begin
        writeln;
        writeln('Carrier Dropped or Comport not opened.');
        writeln('Returning to BBS.');
        cdropped:=true;
        halt;
     end;

  if charin(a) then
    charorigin:=remotechar;
  if (a<>chr(0)) then
    begin
      s := s+a;
      inc(j);
    end
  else
     begin
       If (i mod 50 = 0) then
         begin
           If DVOK then
             DV_Pause
           else
             If Os2OK or WinOK then
             Win_Pause;
         end;
     end;
  delay(2);
  until (i>666) or (j>13);

  If Copy(s,1,3) = 'RIP' then
    begin
      RipYes := true;
      writeln('Rip Detected');
      if charin(a) then
         charorigin:=remotechar;
    end;
 RipDetect := RipYes;
 Swriteln('');
end;

procedure DDAssignSOutput(var f: text);
begin;
 with textrec(f) do begin;
  handle   := $FFFF;
  mode     := fmclosed;
  bufsize  := sizeof(buffer);
  bufptr   := @buffer;
  OpenFunc := @NewCrtOpen;
  CloseFunc:= @NewCrtIgnore;
  Name[0]  := #0;
 end;
end;

procedure InitDoorDriver(ConfigFileName: string);
Var
 i,a: byte;
 b: integer;
 junk: word;

begin;
 initddansi;
 oldtextmode:=lastmode;
 lastsetfore:=99;
 setforecheck:=false;
 badchar:='';
 ansion:=false;
 numlines:=25;
 clrscr;
 window(1,1,80,numlines-1);
 node_num:=1;
 statfore:=7;
 statback:=1;
 GoRip := 0;
 com_port:=0;
 fouled_up:=#0;
 stacked:='';
 hexon:=false;
 buffered:=false;
 cdropped:=false;
 exitsave:=exitproc;
 exitproc:=@myexit;
 firsttime:=true;

 LoadPorts(port1,port2,port3,port4,irq1,irq2,irq3,irq4);
 Loadconfig( ConfigFileName,
             bbs_software,
             user_first_name,user_last_name,
             user_access_level,
             bbs_time_left,
             com_port,
             baud_rate,
             node_num,
             local,
             graphics,
             color1,
             color_chg,
             x00extok,
             board_name,
             pause_code,
             sysop_first_name,
             sysop_last_name,
             maxtime,
             localcol,
             statfore,
             statback,
             statline,
             ESMOK,
             fossilio,
             dropfilepath,
             GoRip,
             lockbaud,
             nodirect,
             port1,port2,port3,port4,irq1,irq2,irq3,irq4);

 numlines:=25;
 if nodirect then directvideo:=false;
 clrscr;
 window(1,1,80,numlines-1);
 textcolor(7);
 textbackground(0);
 default_fore:=7;
 default_back:=0;
 gettime(st_hr,st_mn,st_sc,junk);

 GetBBSInfo( bbs_software,
             user_first_name,user_last_name,
             user_access_level,
             bbs_time_left,
             com_port,
             baud_rate,
             node_num,
             local,
             graphics,
             color1,
             color_chg,
             board_name,
             sysop_first_name,
             sysop_last_name,
             maxtime,
             dropfilepath,
             lockbaud);

 ReSetPorts(port1,port2,port3,port4,irq1,irq2,irq3,irq4);
 if not local then
   begin;
    if FossilIO then AsyncSelectFossil else
      AsyncSelectInternal;
    Open_Async_Port;
   end;

 if fossilio and (initok=false) and (not local) then begin;
  writeln('');
  writeln('Fossil was not initialized properly! You should change to INTERNAL');
  writeln('communications routines.');
  delay(1500);
 end;

 If GoRip = 4 then
     graphics := 5;
 If Graphics <> 5 then
    If RipDetect then
          graphics := 5;

 DV_Aware_ON;
 current_foreground:=default_fore;
 current_background:=default_back;
 if graphics = 3 then
   begin
     set_foreground(statfore);
     set_background(statback);
   end;
 curlinenum:=1;
 time_check:=true;
 time_credit:=0;
 macro_str:='';
 macro:='';
 mintime:=1;
 notime:='';
 user_first_name:=stu(user_first_name);
 user_last_name:=stu(user_last_name);
 stackon:=true;
 if node_num=0 then node_num:=1;
 ddassignsoutput(soutput);
 rewrite(soutput);

end;

end.